home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / scheme / boxer / boxer.lha / loader.lisp < prev    next >
Encoding:
Text File  |  1993-07-17  |  30.0 KB  |  790 lines
  1. ;-*- Syntax: Zetalisp; Mode: Lisp; Package: Boxer;Base: 8; Fonts: CPTFONT -*-
  2.  
  3. ;;; This is a machine independent binary loader for the BOXER system 
  4. ;;;
  5. ;;; (C) Copyright 1984, 1985 Massachusetts Institute of Technology
  6. ;;;
  7. ;;; Permission to use, copy, modify, distribute, and sell this software
  8. ;;; and its documentation for any purpose is hereby granted without fee,
  9. ;;; provided that the above copyright notice appear in all copies and that
  10. ;;; both that copyright notice and this permission notice appear in
  11. ;;; supporting documentation, and that the name of M.I.T. not be used in
  12. ;;; advertising or publicity pertaining to distribution of the software
  13. ;;; without specific, written prior permission.  M.I.T. makes no
  14. ;;; representations about the suitability of this software for any
  15. ;;; purpose.  It is provided "as is" without express or implied warranty.
  16. ;;;
  17. ;;;
  18. ;;;                          +-Data--+
  19. ;;; This file is part of the | BOXER | system.
  20. ;;;                          +-------+
  21. ;;;
  22.  
  23. (DEFSUBST SIGN-EXTEND-IMMEDIATE-OPERAND (NUMBER)
  24.   (IF (LDB-TEST 1301 NUMBER) (- NUMBER %%BIN-OP-IM-ARG-SIZE) NUMBER))
  25.  
  26. (DEFINE-LOAD-COMMAND BIN-OP-NUMBER-IMMEDIATE (IGNORE VALUE)
  27.   (SIGN-EXTEND-IMMEDIATE-OPERAND VALUE))
  28.  
  29. (DEFINE-LOAD-COMMAND-FOR-EFFECT BIN-OP-FORMAT-VERSION (STREAM)
  30.   (LET ((VERSION (BIN-NEXT-VALUE STREAM)))
  31.     (COND ((= VERSION *VERSION-NUMBER*)
  32.        (SETQ *FILE-BIN-VERSION* VERSION))
  33.       ((MEMBER VERSION *SUPPORTED-OBSOLETE-VERSIONS*)
  34.        (SETQ *FILE-BIN-VERSION* VERSION))
  35.       (T
  36.        (FERROR "Format version is ~D, which is not supported" VERSION)))))
  37.  
  38. (DEFINE-LOAD-COMMAND-FOR-EFFECT BIN-OP-FILE-PROPERTY-LIST (STREAM)
  39.   (LET* ((PACKAGE (PKG-FIND-PACKAGE 'BOXER))
  40.      (PLIST (BIN-NEXT-VALUE STREAM)))
  41.     ;; first deal with the package
  42.     (SETQ *LOAD-PACKAGE* (GET (LOCF PLIST) ':PACKAGE))
  43.     ;; now check for how bit arrays were dumped
  44.     (UNLESS (NULL (GET (LOCF PLIST) ':BIT-ARRAY-ORDER))
  45.       (SELECTQ (GET (LOCF PLIST) :BIT-ARRAY-ORDER)
  46.     (:ROW-MAJOR (SETQ *ROW-MAJOR-ORDER?* T))
  47.     (:COLUMN-MAJOR (SETQ *ROW-MAJOR-ORDER?* NIL))
  48.     (OTHERWISE (FERROR "~A Is An Unrecognized Bit Array Description. "
  49.                (GET (LOCF PLIST) :BIT-ARRAY-ORDER)))))))
  50.  
  51. (DEFINE-LOAD-COMMAND-FOR-EFFECT BIN-OP-EOF (IGNORE)
  52.   (*THROW 'BIN-LOAD-DONE T))
  53.  
  54. (DEFINE-LOAD-COMMAND BIN-OP-TABLE-STORE (STREAM)
  55.   (ENTER-BIN-LOAD-TABLE (BIN-NEXT-VALUE STREAM)))
  56.  
  57. (DEFINE-LOAD-COMMAND BIN-OP-TABLE-FETCH-IMMEDIATE (IGNORE INDEX)
  58.   (AREF *BIN-LOAD-TABLE* INDEX))
  59.  
  60. (DEFINE-LOAD-COMMAND BIN-OP-TABLE-FETCH (STREAM)
  61.   (AREF *BIN-LOAD-TABLE* (BIN-NEXT-BYTE STREAM)))
  62.  
  63. (DEFINE-LOAD-COMMAND-FOR-VALUE BIN-OP-SYMBOL (STREAM)
  64.   (INTERN (BIN-NEXT-VALUE STREAM)))
  65.  
  66. ;;; for rel4, if it wants to be in the KEYWORD package, put it into the USER package
  67. ;;; since it was probably a colon name
  68.  
  69. (DEFINE-LOAD-COMMAND-FOR-VALUE BIN-OP-PACKAGE-SYMBOL (STREAM)
  70.   (LET* ((PACKAGE-STRING (BIN-NEXT-VALUE STREAM))
  71.      (PACKAGE (PKG-FIND-PACKAGE #-REL4 PACKAGE-STRING
  72.                     #+REL4(IF (STRING-EQUAL PACKAGE-STRING "KEYWORD")
  73.                           "USER"
  74.                           PACKAGE-STRING)))
  75.      (PNAME (BIN-NEXT-VALUE STREAM)))
  76.     (FUNCALL #+3600 (SI:PKG-PREFIX-INTERN-FUNCTION PACKAGE) #-3600 'INTERN PNAME)))
  77.  
  78. (DEFINE-LOAD-COMMAND-FOR-VALUE BIN-OP-STRING-IMMEDIATE (STREAM LENGTH)
  79.   (LOAD-STRING STREAM LENGTH))
  80.  
  81. (DEFINE-LOAD-COMMAND-FOR-VALUE BIN-OP-STRING (STREAM)
  82.   (LOAD-STRING STREAM))
  83.  
  84. (DEFINE-LOAD-COMMAND-FOR-VALUE BIN-OP-SIMPLE-CONS (STREAM)
  85.   (LET ((THE-CAR (BIN-NEXT-VALUE STREAM))
  86.     (THE-CDR (BIN-NEXT-VALUE STREAM)))
  87.     (CONS THE-CAR THE-CDR)))
  88.  
  89. (DEFINE-LOAD-COMMAND-FOR-VALUE BIN-OP-LIST-IMMEDIATE (STREAM LENGTH)
  90.   (LOAD-LIST STREAM LENGTH))
  91.  
  92. (DEFINE-LOAD-COMMAND-FOR-VALUE BIN-OP-LIST (STREAM)
  93.   (LOAD-LIST STREAM))
  94.  
  95. (DEFINE-LOAD-COMMAND BIN-OP-POSITIVE-FIXNUM (STREAM)
  96.   (LOAD-FIXNUM STREAM))
  97.  
  98. (DEFINE-LOAD-COMMAND BIN-OP-NEGATIVE-FIXNUM (STREAM)
  99.   (- (LOAD-FIXNUM STREAM)))
  100.  
  101. (DEFINE-LOAD-COMMAND BIN-OP-POSITIVE-FLOAT (STREAM)
  102.   (LOAD-FLOAT STREAM NIL))
  103.  
  104. (DEFINE-LOAD-COMMAND BIN-OP-NEGATIVE-FLOAT (STREAM)
  105.   (LOAD-FLOAT STREAM T))
  106.  
  107. (DEFINE-LOAD-COMMAND-FOR-VALUE BIN-OP-ARRAY (STREAM LENGTH)
  108.   (LOAD-ARRAY STREAM LENGTH))
  109.  
  110. (DEFINE-LOAD-COMMAND BIN-OP-INITIALIZE-AND-RETURN-ARRAY (STREAM)
  111.   (INITIALIZE-ARRAY STREAM))
  112.  
  113. (DEFINE-LOAD-COMMAND BIN-OP-INITIALIZE-AND-RETURN-NUMERIC-ARRAY (STREAM)
  114.   (INITIALIZE-NUMERIC-ARRAY STREAM))
  115.  
  116. (DEFINE-LOAD-COMMAND BIN-OP-ROW-IMMEDIATE (STREAM LENGTH)
  117.   (LOAD-ROW STREAM LENGTH))
  118.  
  119. (DEFINE-LOAD-COMMAND BIN-OP-ROW (STREAM)
  120.   (LOAD-ROW STREAM))
  121.  
  122. (DEFINE-LOAD-COMMAND BIN-OP-NAME-ROW-IMMEDIATE (STREAM LENGTH)
  123.   (LOAD-NAME-ROW STREAM LENGTH))
  124.  
  125. (DEFINE-LOAD-COMMAND BIN-OP-NAME-ROW (STREAM)
  126.   (LOAD-NAME-ROW STREAM))
  127.  
  128. (DEFINE-LOAD-COMMAND BIN-OP-NAME-AND-INPUT-ROW-IMMEDIATE (STREAM LENGTH)
  129.   (LOAD-AND-CONVERT-TO-NAME-ROW STREAM LENGTH))
  130.  
  131. (DEFINE-LOAD-COMMAND BIN-OP-NAME-AND-INPUT-ROW (STREAM)
  132.   (LOAD-AND-CONVERT-TO-NAME-ROW STREAM))
  133.  
  134. ;;; Box loading commands
  135.  
  136. (DEFINE-LOAD-COMMAND BIN-OP-DOIT-BOX (STREAM)
  137.   (LOAD-DOIT-BOX STREAM))
  138.  
  139. (DEFINE-LOAD-COMMAND BIN-OP-DATA-BOX (STREAM)
  140.   (LOAD-DATA-BOX STREAM))
  141.  
  142. (DEFINE-LOAD-COMMAND BIN-OP-PORT-BOX (STREAM)
  143.   (LOAD-PORT-BOX STREAM))
  144.  
  145. (DEFINE-LOAD-COMMAND BIN-OP-GRAPHICS-BOX (STREAM)
  146.   (LOAD-GRAPHICS-BOX STREAM))
  147.  
  148. (DEFINE-LOAD-COMMAND BIN-OP-TURTLE-BOX (STREAM)
  149.   (LOAD-TURTLE-BOX STREAM NIL))
  150.  
  151. (DEFINE-LOAD-COMMAND BIN-OP-TURTLE-BOX* (STREAM)
  152.   (LOAD-TURTLE-BOX STREAM T))
  153.  
  154. (DEFINE-LOAD-COMMAND BIN-OP-GRAPHICS-DATA-BOX (STREAM)
  155.   (LOAD-GRAPHICS-DATA-BOX STREAM))
  156.  
  157. (DEFINE-LOAD-COMMAND BIN-OP-SPRITE-BOX (STREAM)
  158.   (LOAD-SPRITE-BOX STREAM))
  159.  
  160. (DEFINE-LOAD-COMMAND BIN-OP-LL-BOX (STREAM)
  161.   (LOAD-LL-BOX STREAM))
  162.  
  163. (DEFINE-LOAD-COMMAND-FOR-EFFECT BIN-OP-END-OF-BOX (IGNORE)
  164.   (*THROW 'DONE-WITH-BOX T))
  165.  
  166. ;;; Graphics loading commands
  167.  
  168. (DEFINE-LOAD-COMMAND-FOR-VALUE BIN-OP-GRAPHICS-SHEET (STREAM)
  169.   (LOAD-GRAPHICS-SHEET STREAM))
  170.  
  171. (DEFINE-LOAD-COMMAND BIN-OP-GRAPHICS-OBJECT (STREAM)
  172.   (LOAD-GRAPHICS-OBJECT STREAM))
  173.  
  174. (DEFINE-LOAD-COMMAND BIN-OP-TURTLE (STREAM)
  175.   (LOAD-TURTLE STREAM))
  176.  
  177.  
  178. ;;;The actual LOAD functions
  179.  
  180. (DEFUN LOAD-LIST (STREAM &OPTIONAL (LENGTH (BIN-NEXT-VALUE STREAM)))
  181.   (LET ((LIST (MAKE-LIST LENGTH)))
  182.     (LOOP FOR I FROM 0 BELOW LENGTH
  183.       FOR L = LIST THEN (CDR L)
  184.       DO (RPLACA L (BIN-NEXT-VALUE STREAM)))
  185.     LIST))
  186.  
  187. (DEFUN LOAD-STRING (STREAM &OPTIONAL (LENGTH (BIN-NEXT-VALUE STREAM)) &AUX STRING)
  188.   (SETQ STRING (MAKE-ARRAY LENGTH ':TYPE 'ART-STRING))
  189.   (LOOP FOR I FROM 0 BELOW LENGTH
  190.     WITH WORD
  191.     WHEN (ZEROP (\ I 2))
  192.     DO (ASET (LDB 0010 (SETQ WORD (BIN-NEXT-BYTE STREAM))) STRING I)
  193.     ELSE DO (ASET (LDB 1010 WORD) STRING I))
  194.   STRING)
  195.  
  196. (DEFUN LOAD-FIXNUM (STREAM &OPTIONAL (LENGTH (BIN-NEXT-VALUE STREAM)))
  197.   ;; Kludge around to avoid having to create intermediate bignum masks inside DPB
  198.   (COND ((= LENGTH 1) (BIN-NEXT-BYTE STREAM))
  199.     #+3600
  200.     ((= LENGTH 2) (SI:MAKE-32-BIT-NUMBER (BIN-NEXT-BYTE STREAM) (BIN-NEXT-BYTE STREAM)))
  201.     (T (LOOP FOR I FROM 0 BELOW LENGTH
  202.          FOR POS FROM 0 BY 16.
  203.          WITH WORD = 0
  204.          DO (SETQ WORD (DEPOSIT-BYTE WORD POS 16. (BIN-NEXT-BYTE STREAM)))
  205.          FINALLY (RETURN WORD)))))
  206.  
  207. (DEFUN LOAD-FLOAT (STREAM NEGATIVE)
  208.   (LET ((MANTISSA (BIN-NEXT-VALUE STREAM))
  209.     (EXPONENT (BIN-NEXT-VALUE STREAM)))
  210.     (MAKE-FLOAT-INTERNAL NEGATIVE MANTISSA EXPONENT)))
  211.  
  212. #-3600
  213. (DEFUN MAKE-FLOAT-INTERNAL (NEGATIVE MANTISSA EXPONENT)
  214.   (IF (ZEROP MANTISSA)
  215.       0.0
  216.       (LET ((FLOAT (%ALLOCATE-AND-INITIALIZE DTP-EXTENDED-NUMBER DTP-HEADER  ;Cons a flonum
  217.              (%LOGDPB SI:%HEADER-TYPE-FLONUM SI:%%HEADER-TYPE-FIELD 0) 0 NIL 2)))
  218.     (LET ((EXTRA-SIG (- (HAULONG MANTISSA) 37)))
  219.       (COND ((NOT (ZEROP EXTRA-SIG))
  220.          (SETQ MANTISSA (ASH MANTISSA (- EXTRA-SIG)))
  221.          (INCF EXPONENT EXTRA-SIG))))
  222.     (%P-DPB-OFFSET (LDB 3010 MANTISSA) 0010 FLOAT 0)
  223.     (%P-DPB-OFFSET (LDB 2010 MANTISSA) 2010 FLOAT 1)
  224.     (%P-DPB-OFFSET (LDB 0020 MANTISSA) 0020 FLOAT 1)
  225.     (%P-DPB-OFFSET (+ EXPONENT 2037) 1013 FLOAT 0)
  226.     (AND NEGATIVE (SETQ FLOAT (- FLOAT)))
  227.     FLOAT)))
  228.  
  229. #+3600
  230. (DEFUN MAKE-FLOAT-INTERNAL (NEGATIVE MANTISSA EXPONENT)
  231.   (IF (ZEROP MANTISSA)
  232.       (%MAKE-POINTER SI:DTP-FLOAT 0)
  233.       (LET ((EXTRA-SIG (- (HAULONG MANTISSA) (1+ SI:%%FLOAT-FRACTION))))
  234.     (COND ((NOT (ZEROP EXTRA-SIG))
  235.            (SETQ MANTISSA (ASH MANTISSA (- EXTRA-SIG)))
  236.            (INCF EXPONENT EXTRA-SIG))))
  237.       (SI:%FLONUM (SI:%LOGDPB (IF NEGATIVE 1 0) SI:%%FLOAT-SIGN
  238.             (DPB (+ EXPONENT (+ 126. 24.)) SI:%%FLOAT-EXPONENT
  239.                  (DPB MANTISSA SI:%%FLOAT-FRACTION 0))))))
  240.  
  241. (DEFUN TRANSPOSE-BIT-ARRAY (ARRAY)
  242.   "Returns a new array with width = heigth of arg and height - width of arg"
  243.   (MULTIPLE-VALUE-BIND (DIMS OPTS)
  244.       (DECODE-ARRAY ARRAY)
  245.     (LET ((RETURN-ARRAY (LEXPR-FUNCALL #'MAKE-ARRAY (REVERSE DIMS) OPTS)))
  246.       (COPY-ARRAY-CONTENTS ARRAY RETURN-ARRAY)
  247.       RETURN-ARRAY)))
  248.  
  249. (DEFUN LOAD-ARRAY (STREAM OPT-LENGTH)
  250.   (LET ((DIMENSIONS (BIN-NEXT-VALUE STREAM))
  251.     (OPTIONS (MAKE-LIST (* OPT-LENGTH 2)))
  252.     (PACKAGE PACKAGE))
  253.     (LOOP FOR I FROM 0 BELOW OPT-LENGTH
  254.       FOR L = OPTIONS THEN (CDDR L)
  255.       DO (LET ((KEYWORD (BIN-NEXT-VALUE STREAM)))
  256.            (SETF (CAR L) KEYWORD))
  257.       (SETF (CADR L) (BIN-NEXT-VALUE STREAM)))
  258.     #-3600
  259.     (LET ((TYPE (GET (LOCF OPTIONS) ':TYPE)))
  260.       (AND TYPE (LISTP TYPE) (EQ (CADR TYPE) 'SI:ART-BOOLEAN)
  261.        (SETF (CADR TYPE) 'ART-1B)))
  262.     (LEXPR-FUNCALL #'MAKE-ARRAY DIMENSIONS OPTIONS)))
  263.  
  264. (DEFUN INITIALIZE-ARRAY (STREAM)
  265.   (LET* ((ARRAY (BIN-NEXT-VALUE STREAM))
  266.      (LENGTH (BIN-NEXT-VALUE STREAM))
  267.      (Q-ARRAY (IF (= (#-LMITI ARRAY-#-DIMS #+LMITI ARRAY-RANK ARRAY) 1) ARRAY
  268.               (MAKE-ARRAY LENGTH ':DISPLACED-TO ARRAY))))
  269.     (DOTIMES (I LENGTH)
  270.       (ASET (BIN-NEXT-VALUE STREAM) Q-ARRAY I))
  271.     (OR (EQ ARRAY Q-ARRAY) (RETURN-ARRAY Q-ARRAY))
  272.     ARRAY))
  273.  
  274. (DEFUN INITIALIZE-NUMERIC-ARRAY (STREAM)
  275.   (LET* ((ARRAY (BIN-NEXT-VALUE STREAM))
  276.      (LENGTH (BIN-NEXT-VALUE STREAM))
  277.      (16-ARRAY (IF (AND (= (#-LMITI ARRAY-#-DIMS #+LMITI ARRAY-RANK ARRAY) 1)
  278.                 #-TI(= (AREF #'ARRAY-BITS-PER-ELEMENT
  279.                      (SI:ARRAY-TYPE-FIELD ARRAY)) 16.)
  280.                 ;;Explorers must have some function that correctly hacks this....
  281.                 #+TI(= (CADR (ARRAY-ELEMENT-TYPE ARRAY)) 20000)
  282.                 (NOT (ARRAY-HAS-LEADER-P ARRAY)))
  283.                ARRAY
  284.                (MAKE-ARRAY LENGTH ':TYPE 'ART-16B ':DISPLACED-TO ARRAY))))
  285.     (TELL STREAM :STRING-IN NIL 16-ARRAY 0 LENGTH)
  286.     (OR (EQ ARRAY 16-ARRAY) (RETURN-ARRAY 16-ARRAY))
  287.     (IF (EQ *ROW-MAJOR-ORDER?* *BIT-ARRAYS-ARE-ROW-MAJOR-ORDERED?*)
  288.     ;; dumping order and current order match
  289.     ARRAY
  290.     (TRANSPOSE-BIT-ARRAY ARRAY))))
  291.  
  292. ;;; loading boxer objects
  293.  
  294. ;; them old compatibility blues
  295. (DEFVAR %%OLD-FONT-NO-FIELD #O1010)
  296.  
  297. (DEFUN CONVERT-CHARACTER-FONT-FIELD (CHA)
  298.   (COND ((BOX? CHA) CHA)
  299.     ((= *FILE-BIN-VERSION* *VERSION-NUMBER*) CHA)
  300.     ((= *FILE-BIN-VERSION* 1)
  301.      (DPB (LDB %%OLD-FONT-NO-FIELD CHA) %%BOXER-FONT-NO-FIELD
  302.           (LDB %%BOXER-CHA-CODE-FIELD CHA)))
  303.     (T CHA)))
  304.  
  305. (DEFUN LOAD-ROW (STREAM &OPTIONAL (LENGTH (BIN-NEXT-VALUE STREAM)))
  306.   (LET ((NEW-ROW (MAKE-INSTANCE 'ROW)))
  307.     (LOOP FOR I FROM 1 TO LENGTH
  308.       DO (TELL NEW-ROW :APPEND-CHA
  309.            (CONVERT-CHARACTER-FONT-FIELD (BIN-NEXT-VALUE STREAM))))
  310.     NEW-ROW))
  311.  
  312. (DEFUN LOAD-NAME-ROW (STREAM &OPTIONAL (LENGTH (BIN-NEXT-VALUE STREAM)))
  313.   (LET* ((NAME (BIN-NEXT-VALUE STREAM))
  314.      (PREV-NAME-OR-FIRST-CHA (BIN-NEXT-VALUE STREAM))
  315.      (NEW-ROW (MAKE-INSTANCE 'NAME-ROW ':CACHED-NAME NAME)))
  316.     (LOOP
  317.       INITIALLY (UNLESS (STRINGP PREV-NAME-OR-FIRST-CHA)
  318.           (TELL NEW-ROW :APPEND-CHA
  319.             (CONVERT-CHARACTER-FONT-FIELD PREV-NAME-OR-FIRST-CHA)))
  320.       FOR I FROM (IF (STRINGP PREV-NAME-OR-FIRST-CHA) 1 2) TO LENGTH
  321.       DO (TELL NEW-ROW :APPEND-CHA (CONVERT-CHARACTER-FONT-FIELD (BIN-NEXT-VALUE STREAM))))
  322.     NEW-ROW))
  323.  
  324. ;;;for compatibility with old BOXTOP files
  325.  
  326. (DEFUN LOAD-AND-CONVERT-TO-NAME-ROW (STREAM &OPTIONAL (LENGTH (BIN-NEXT-VALUE STREAM)))
  327.   (LET* ((NAME (BIN-NEXT-VALUE STREAM))
  328.      (NEW-ROW (MAKE-INSTANCE 'NAME-ROW ':CACHED-NAME NAME)))
  329.     (LOOP FOR I FROM 1 TO LENGTH
  330.       DO (TELL NEW-ROW :APPEND-CHA
  331.            (CONVERT-CHARACTER-FONT-FIELD (BIN-NEXT-VALUE STREAM))))
  332.     NEW-ROW))
  333.  
  334. ;(DEFUN LOAD-NAME-AND-INPUT-ROW (STREAM &OPTIONAL (LENGTH (BIN-NEXT-VALUE STREAM)))
  335. ;  (LET* ((NAME (BIN-NEXT-VALUE STREAM))
  336. ;     (NEW-ROW (MAKE-INSTANCE 'NAME-AND-INPUT-ROW ':CACHED-NAME NAME)))
  337. ;    (LOOP FOR I FROM 1 TO LENGTH
  338. ;      DO (TELL NEW-ROW :APPEND-CHA (BIN-NEXT-VALUE STREAM)))
  339. ;    NEW-ROW))
  340.  
  341. (DEFUN LOAD-DOIT-BOX (STREAM)
  342.   (LOAD-VANILLA-BOX (STREAM)
  343.     (LET* ((FIRST-ROW (BIN-NEXT-VALUE STREAM))
  344.        (DOIT-BOX (MAKE-INSTANCE 'DOIT-BOX ':NAME NAME ':DISPLAY-STYLE-LIST DISPLAY-LIST
  345.                                       ':STATIC-VARIABLES-ALIST ENVIRONMENT
  346.                           ':LOCAL-LIBRARY LOCAL-LIBRARY
  347.                           ':FIRST-INFERIOR-ROW FIRST-ROW)))
  348.       ;; we have to attach the first row to the box
  349.       (TELL (TELL DOIT-BOX :FIRST-INFERIOR-ROW) :SET-SUPERIOR-BOX DOIT-BOX)
  350.       ;; if it has a name row, then we have to attach it to the box
  351.       (WHEN (NAME-ROW? NAME)
  352.     (TELL NAME :SET-SUPERIOR-BOX DOIT-BOX))
  353.       (*CATCH 'DONE-WITH-BOX
  354.     (LOOP DOING 
  355.           (LET ((NEXT-STUFF (BIN-NEXT-VALUE STREAM)))
  356.         (COND ((ROW? NEXT-STUFF)
  357.                (TELL DOIT-BOX :APPEND-ROW NEXT-STUFF))
  358.               ((OR (EQ NEXT-STUFF *EXPORT-ALL-VARIABLES-MARKER*)
  359.                (LISTP NEXT-STUFF))
  360.                (TELL DOIT-BOX :SET-EXPORTS NEXT-STUFF))))))
  361.       DOIT-BOX)))
  362.  
  363. (DEFUN LOAD-DATA-BOX (STREAM)
  364.   (LOAD-VANILLA-BOX (STREAM)
  365.     (LET* ((FIRST-ROW (BIN-NEXT-VALUE STREAM))
  366.        (DATA-BOX (MAKE-INSTANCE 'DATA-BOX ':NAME NAME ':DISPLAY-STYLE-LIST DISPLAY-LIST
  367.                                       ':STATIC-VARIABLES-ALIST ENVIRONMENT
  368.                           ':FIRST-INFERIOR-ROW FIRST-ROW
  369.                           ':LOCAL-LIBRARY LOCAL-LIBRARY)))
  370.       (TELL (TELL DATA-BOX :FIRST-INFERIOR-ROW) :SET-SUPERIOR-BOX DATA-BOX)
  371.       ;; if it has a name row, then we have to attach it to the box
  372.       (WHEN (NAME-ROW? NAME)
  373.     (TELL NAME :SET-SUPERIOR-BOX DATA-BOX))
  374.       (*CATCH 'DONE-WITH-BOX
  375.     (LOOP DOING
  376.           (LET ((NEXT-STUFF (BIN-NEXT-VALUE STREAM)))
  377.         (COND ((ROW? NEXT-STUFF)
  378.                (TELL DATA-BOX :APPEND-ROW NEXT-STUFF))
  379.               ((OR (EQ NEXT-STUFF *EXPORT-ALL-VARIABLES-MARKER*)
  380.                (LISTP NEXT-STUFF))
  381.                (TELL DATA-BOX :SET-EXPORTS NEXT-STUFF))))))
  382.       DATA-BOX)))
  383.  
  384. (DEFUN LOAD-PORT-BOX (STREAM)
  385.   (LOAD-VANILLA-BOX (STREAM)
  386.     (LET* ((PORT (BIN-NEXT-VALUE STREAM))
  387.        (PORT-BOX (MAKE-INSTANCE 'PORT-BOX ':NAME NAME ':DISPLAY-STYLE-LIST DISPLAY-LIST
  388.                     ':STATIC-VARIABLES-ALIST ENVIRONMENT
  389.                     ':LOCAL-LIBRARY LOCAL-LIBRARY)))
  390.       (TELL PORT-BOX :SET-PORT-TO-BOX PORT)
  391.       ;; if it has a name and input row, then we have to attach it to the box
  392.       (WHEN (NAME-ROW? NAME)
  393.     (TELL NAME :SET-SUPERIOR-BOX PORT-BOX))
  394.       (*CATCH 'DONE-WITH-BOX
  395.     (LET ((MAYBE-EXPORTS (BIN-NEXT-VALUE STREAM)))
  396.       (WHEN (OR (EQ MAYBE-EXPORTS *EXPORT-ALL-VARIABLES-MARKER*) (LISTP MAYBE-EXPORTS))
  397.         (TELL PORT-BOX :SET-EXPORTS MAYBE-EXPORTS)))
  398.     (BIN-NEXT-VALUE STREAM)
  399.     (FERROR "the port, ~S, was dumped with extraneous information" PORT-BOX))    ;here
  400.       PORT-BOX)))
  401.  
  402. (DEFUN HOOKUP-SPRITES (ROW GBOX)
  403.   (LOOP FOR BOX IN (TELL ROW :BOXES-IN-ROW)
  404.     WHEN (SPRITE-BOX?  BOX)
  405.     DO (LET ((TURTLE (TELL BOX :ASSOCIATED-TURTLE)))
  406.          (TELL GBOX :ADD-GRAPHICS-OBJECT TURTLE)
  407.          (TELL TURTLE :DRAW))
  408.     (LOOP FOR SROW IN (TELL BOX :ROWS) DO
  409.           (HOOKUP-SPRITES SROW BOX))))
  410.  
  411. ;;; pre-Jeremy-graphics have turtles in the alist and NO sprite boxes.  We need to splice 
  412. ;;; the turtles out of the binding list, give them sprite boxes and splice the sprite boxes 
  413. ;;; into the binding list
  414.  
  415. (DEFUN CONVERT-TO-NEW-GRAPHICS (ALIST)
  416.   (LOOP WITH SPRITE-BOXES = NIL
  417.     FOR BINDING IN ALIST
  418.     INITIALLY (SETQ ALIST (DELQ (ASSQ :ORIGINAL-TURTLE ALIST) ALIST))
  419.     WHEN (TURTLE? (CDR BINDING))
  420.     DO (LET ((SB (MAKE-SPRITE-BOX (CDR BINDING))))
  421.          (PUSH SB SPRITE-BOXES)
  422.          (SETQ ALIST (DELQ (RASSQ (CDR BINDING) ALIST) ALIST))
  423.          (PUSH (CONS (CAR BINDING) SB) ALIST)
  424.          (TELL SB :SET-NAME (MAKE-NAME-ROW (NCONS (CAR BINDING)))))
  425.     FINALLY
  426.       (RETURN (VALUES ALIST (MAKE-ROW SPRITE-BOXES NIL)))))
  427.  
  428. (DEFUN LOAD-GRAPHICS-BOX (STREAM)
  429.   (IF (MEMBER *FILE-BIN-VERSION* '(1. 2.))
  430.       ;; old version of graphics boxes
  431.       (LOAD-VANILLA-BOX (STREAM)
  432.     (LET* ((PICTURE (BIN-NEXT-VALUE STREAM))
  433.            ;; we need do this to take care of dem old compatibility blues...
  434.            (GRAPHICS-SHEET (IF (GRAPHICS-SHEET? PICTURE)
  435.                    PICTURE
  436.                    (%MAKE-GRAPHICS-SHEET #-LMITI(ARRAY-DIMENSION-N 1 PICTURE)
  437.                              #-LMITI(ARRAY-DIMENSION-N 2 PICTURE)
  438.                              #+LMITI(ARRAY-DIMENSION PICTURE 1)
  439.                              #+LMITI(ARRAY-DIMENSION PICTURE 2)
  440.                              PICTURE
  441.                              NIL)))
  442.            (GRAPHICS-BOX (MAKE-INSTANCE 'GRAPHICS-BOX ':NAME NAME
  443.                         ':DISPLAY-STYLE-LIST DISPLAY-LIST
  444.                         ':STATIC-VARIABLES-ALIST ENVIRONMENT
  445.                         ':LOCAL-LIBRARY LOCAL-LIBRARY
  446.                         ':GRAPHICS-SHEET GRAPHICS-SHEET)))
  447.       (SETF (GRAPHICS-SHEET-SUPERIOR-BOX GRAPHICS-SHEET) GRAPHICS-BOX)
  448.       ;; if it has a name and unput row, then we have to attach it to the box
  449.       (WHEN (NAME-ROW? NAME)
  450.         (TELL NAME :SET-SUPERIOR-BOX GRAPHICS-BOX))
  451.       (*CATCH 'DONE-WITH-BOX
  452.         (LET ((MAYBE-EXPORTS (BIN-NEXT-VALUE STREAM)))
  453.           (WHEN (OR (EQ MAYBE-EXPORTS *EXPORT-ALL-VARIABLES-MARKER*)(LISTP MAYBE-EXPORTS))
  454.         (TELL GRAPHICS-BOX :SET-EXPORTS MAYBE-EXPORTS)))
  455.         (BIN-NEXT-VALUE STREAM)   ;if this doesn't throw like it should we signal an error
  456.         (FERROR "the graphics box, ~S, was dumped with extraneous information"
  457.             GRAPHICS-BOX))
  458.       (MULTIPLE-VALUE-BIND (BINDINGS ROW)
  459.           (CONVERT-TO-NEW-GRAPHICS (TELL GRAPHICS-BOX :GET-STATIC-VARIABLES-ALIST))
  460.         (TELL GRAPHICS-BOX :SET-STATIC-VARIABLES-ALIST BINDINGS)
  461.         (TELL GRAPHICS-BOX :APPEND-ROW ROW)
  462.         (HOOKUP-SPRITES ROW GRAPHICS-BOX))
  463.       GRAPHICS-BOX))
  464.       ;; Otherwise use the new version
  465.       (LOAD-VANILLA-BOX (STREAM)
  466.     (LET* ((PICTURE (BIN-NEXT-VALUE STREAM))
  467.            ;; we need do this to take care of dem old compatibility blues...
  468.            (GRAPHICS-SHEET (IF (GRAPHICS-SHEET? PICTURE)
  469.                    PICTURE
  470.                    (%MAKE-GRAPHICS-SHEET #-LMITI(ARRAY-DIMENSION-N 1 PICTURE)
  471.                              #-LMITI(ARRAY-DIMENSION-N 2 PICTURE)
  472.                              #+LMITI(ARRAY-DIMENSION PICTURE 1)
  473.                              #+LMITI(ARRAY-DIMENSION PICTURE 2)
  474.                              PICTURE
  475.                              NIL)))
  476.            (FIRST-ROW (BIN-NEXT-VALUE STREAM))
  477.            (GRAPHICS-BOX (MAKE-INSTANCE 'GRAPHICS-BOX ':NAME NAME
  478.                         ':DISPLAY-STYLE-LIST DISPLAY-LIST
  479.                         ':STATIC-VARIABLES-ALIST ENVIRONMENT
  480.                         ':FIRST-INFERIOR-ROW FIRST-ROW
  481.                         ':LOCAL-LIBRARY LOCAL-LIBRARY
  482.                         ':GRAPHICS-SHEET GRAPHICS-SHEET)))
  483.       (TELL (TELL GRAPHICS-BOX :FIRST-INFERIOR-ROW ) :SET-SUPERIOR-BOX GRAPHICS-BOX)
  484.       (HOOKUP-SPRITES (TELL GRAPHICS-BOX :FIRST-INFERIOR-ROW) GRAPHICS-BOX)
  485.       (SETF (GRAPHICS-SHEET-SUPERIOR-BOX GRAPHICS-SHEET) GRAPHICS-BOX)
  486.       ;; if it has a name and unput row, then we have to attach it to the box
  487.       (WHEN (NAME-ROW? NAME)
  488.         (TELL NAME :SET-SUPERIOR-BOX GRAPHICS-BOX))
  489.       (*CATCH 'DONE-WITH-BOX
  490.         (LOOP DOING
  491.           (LET ((NEXT-STUFF (BIN-NEXT-VALUE STREAM)))
  492.         (COND ((ROW? NEXT-STUFF)
  493.                (TELL GRAPHICS-BOX :APPEND-ROW NEXT-STUFF)
  494.                (HOOKUP-SPRITES NEXT-STUFF GRAPHICS-BOX))
  495.               ((OR (EQ NEXT-STUFF *EXPORT-ALL-VARIABLES-MARKER*)
  496.                (LISTP NEXT-STUFF))
  497.                (TELL GRAPHICS-BOX :SET-EXPORTS NEXT-STUFF))))))
  498.       GRAPHICS-BOX))))
  499.  
  500. (DEFUN LOAD-GRAPHICS-DATA-BOX (STREAM)
  501.   (LOAD-VANILLA-BOX (STREAM)
  502.     (LET* ((PICTURE (BIN-NEXT-VALUE STREAM))
  503.        ;; we need do this to take care of dem old compatibility blues...
  504.        (GRAPHICS-SHEET (IF (GRAPHICS-SHEET? PICTURE)
  505.                    PICTURE
  506.                    (%MAKE-GRAPHICS-SHEET #-LMITI(ARRAY-DIMENSION-N 1 PICTURE)
  507.                              #-LMITI(ARRAY-DIMENSION-N 2 PICTURE)
  508.                              #+LMITI(ARRAY-DIMENSION PICTURE 1)
  509.                              #+LMITI(ARRAY-DIMENSION PICTURE 2)
  510.                              PICTURE
  511.                              NIL)))
  512.        (FIRST-ROW (BIN-NEXT-VALUE STREAM))
  513.        (GRAPHICS-DATA-BOX (MAKE-INSTANCE 'GRAPHICS-DATA-BOX ':NAME NAME
  514.                     ':DISPLAY-STYLE-LIST DISPLAY-LIST
  515.                     ':STATIC-VARIABLES-ALIST ENVIRONMENT
  516.                     ':FIRST-INFERIOR-ROW FIRST-ROW
  517.                     ':LOCAL-LIBRARY LOCAL-LIBRARY
  518.                     ':GRAPHICS-SHEET GRAPHICS-SHEET)))
  519.       (TELL (TELL GRAPHICS-DATA-BOX :FIRST-INFERIOR-ROW ) :SET-SUPERIOR-BOX GRAPHICS-DATA-BOX)
  520.       (HOOKUP-SPRITES (TELL GRAPHICS-DATA-BOX :FIRST-INFERIOR-ROW) GRAPHICS-DATA-BOX)
  521.       (SETF (GRAPHICS-SHEET-SUPERIOR-BOX GRAPHICS-SHEET) GRAPHICS-DATA-BOX)
  522.       ;; if it has a name and unput row, then we have to attach it to the box
  523.       (WHEN (NAME-ROW? NAME)
  524.     (TELL NAME :SET-SUPERIOR-BOX GRAPHICS-DATA-BOX))
  525.       (*CATCH 'DONE-WITH-BOX
  526.     (LOOP DOING
  527.           (LET ((NEXT-STUFF (BIN-NEXT-VALUE STREAM)))
  528.         (COND ((ROW? NEXT-STUFF)
  529.                (TELL GRAPHICS-DATA-BOX :APPEND-ROW NEXT-STUFF)
  530.                (HOOKUP-SPRITES NEXT-STUFF GRAPHICS-DATA-BOX))
  531.               ((OR (EQ NEXT-STUFF *EXPORT-ALL-VARIABLES-MARKER*)
  532.                (LISTP NEXT-STUFF))
  533.                (TELL GRAPHICS-DATA-BOX :SET-EXPORTS NEXT-STUFF))))))
  534.       GRAPHICS-DATA-BOX)))
  535.  
  536. (DEFUN HOOKUP-SPRITE-INSTANCE-VARS (ALIST TURTLE)
  537.   (LOOP FOR PAIR IN ALIST
  538.     DO
  539.     (SELECTQ (CAR PAIR)
  540.       ((BU:SHAPE)
  541.        (TELL TURTLE :ADD-SHAPE-BOX (CDR PAIR)))
  542.       ((BU:SIZE)
  543.        (TELL TURTLE :ADD-SIZE-BOX (CDR PAIR)))
  544.       ((BU:XPOS)
  545.        (TELL TURTLE :ADD-XPOS-BOX (CDR PAIR)))
  546.       ((BU:YPOS)
  547.        (TELL TURTLE :ADD-YPOS-BOX (CDR PAIR)))
  548.       ((BU:HEADING)
  549.        (TELL TURTLE :ADD-HEADING-BOX (CDR PAIR)))
  550.       ((BU:PEN)
  551.        (TELL TURTLE :ADD-PEN-BOX (CDR PAIR)))
  552.       ((BU:HOME)
  553.        (TELL TURTLE :ADD-HOME-BOX (CDR PAIR)))
  554.       ((BU:SHOWN)
  555.        (TELL TURTLE :ADD-SHOWN-P-BOX (CDR PAIR)))) ))
  556.  
  557. (DEFUN LOAD-SPRITE-BOX (STREAM)
  558.   (LOAD-VANILLA-BOX (STREAM)
  559.     (LET* ((TURTLE (BIN-NEXT-VALUE STREAM))
  560.        (FIRST-ROW (BIN-NEXT-VALUE STREAM))
  561.        (SPRITE-BOX (MAKE-INSTANCE 'SPRITE-BOX ':NAME NAME
  562.                     ':DISPLAY-STYLE-LIST DISPLAY-LIST
  563.                     ':STATIC-VARIABLES-ALIST ENVIRONMENT
  564.                     ':FIRST-INFERIOR-ROW FIRST-ROW
  565.                     ':LOCAL-LIBRARY LOCAL-LIBRARY
  566.                     ':ASSOCIATED-TURTLE TURTLE)))
  567.       (TELL TURTLE :SET-SPRITE-BOX SPRITE-BOX)
  568.       (TELL (TELL SPRITE-BOX :FIRST-INFERIOR-ROW) :SET-SUPERIOR-BOX SPRITE-BOX)
  569.       (WHEN (NAME-ROW? NAME)
  570.     (TELL NAME :SET-SUPERIOR-BOX SPRITE-BOX))
  571.       (HOOKUP-SPRITE-INSTANCE-VARS ENVIRONMENT TURTLE)
  572.       (*CATCH 'DONE-WITH-BOX
  573.     (LOOP DOING
  574.           (LET ((NEXT-STUFF (BIN-NEXT-VALUE STREAM)))
  575.         (COND ((ROW? NEXT-STUFF)
  576.                (TELL SPRITE-BOX :APPEND-ROW NEXT-STUFF))
  577.               ((OR (EQ NEXT-STUFF *EXPORT-ALL-VARIABLES-MARKER*)
  578.                (LISTP NEXT-STUFF))
  579.                (TELL SPRITE-BOX :SET-EXPORTS NEXT-STUFF))))))
  580.       SPRITE-BOX)))
  581.  
  582. (DEFUN LOAD-TURTLE-BOX-WITH-STATE (STREAM)
  583.   (LOAD-VANILLA-BOX (STREAM)
  584.     (LET* ((PICTURE (BIN-NEXT-VALUE STREAM))
  585.        (GRAPHICS-SHEET (IF (GRAPHICS-SHEET? PICTURE)
  586.                    PICTURE
  587.                    (%MAKE-GRAPHICS-SHEET (CADR DISPLAY-LIST)
  588.                              (CADDR DISPLAY-LIST)
  589.                              PICTURE
  590.                              NIL)))
  591.        (IGNORE ;x-pos
  592.          (BIN-NEXT-VALUE STREAM))
  593.        (IGNORE ;y-pos
  594.          (BIN-NEXT-VALUE STREAM))
  595.        (IGNORE ;heading
  596.          (BIN-NEXT-VALUE STREAM))
  597.        (IGNORE ;sin-heading
  598.          (BIN-NEXT-VALUE STREAM))
  599.        (IGNORE ;cos-heading
  600.          (BIN-NEXT-VALUE STREAM))
  601.        (IGNORE ;pen-mode
  602.          (BIN-NEXT-VALUE STREAM))
  603.        (IGNORE ;shown-p
  604.          (BIN-NEXT-VALUE STREAM))
  605.        (TURTLE-BOX (MAKE-INSTANCE 'GRAPHICS-BOX ':NAME NAME
  606.                       ':DISPLAY-STYLE-LIST DISPLAY-LIST
  607.                       ':STATIC-VARIABLES-ALIST ENVIRONMENT
  608.                       ':GRAPHICS-SHEET GRAPHICS-SHEET))
  609. ;       (TURTLE (MAKE-INSTANCE 'TURTLE ':X-POSITION X-POS ':Y-POSITION Y-POS
  610. ;                  ':HEADING HEADING ':SIN-HEADING SIN-HEADING
  611. ;                  ':COS-HEADING COS-HEADING ':PEN-MODE PEN-MODE
  612. ;                  ':SHOWN-P SHOWN-P))
  613.        )
  614.       LOCAL-LIBRARY  ;the variable was bound but....
  615.       (SETF (GRAPHICS-SHEET-SUPERIOR-BOX GRAPHICS-SHEET) TURTLE-BOX)
  616.       ;; if it has a name and input row, then we have to attach it to the box
  617. ;      (TELL TURTLE-BOX :ADD-GRAPHICS-OBJECT TURTLE)
  618. ;      (TELL TURTLE :DRAW)
  619.       (WHEN (NAME-ROW? NAME)
  620.     (TELL NAME :SET-SUPERIOR-BOX TURTLE-BOX))
  621.       (*CATCH 'DONE-WITH-BOX
  622.     (LET ((MAYBE-EXPORTS (BIN-NEXT-VALUE STREAM)))
  623.       (WHEN (OR (EQ MAYBE-EXPORTS *EXPORT-ALL-VARIABLES-MARKER*) (LISTP MAYBE-EXPORTS))
  624.         (TELL TURTLE-BOX :SET-EXPORTS MAYBE-EXPORTS)))
  625.     (BIN-NEXT-VALUE STREAM)    ;if this doesn't throw like it should we signal an error
  626.     (FERROR "the graphics box, ~S, was dumped with extraneous information"
  627.         TURTLE-BOX))
  628.       TURTLE-BOX)))
  629.  
  630. (DEFUN LOAD-TURTLE-BOX-WITHOUT-STATE (STREAM)
  631.   (LOAD-VANILLA-BOX (STREAM)
  632.     (LET* ((WID (CADR DISPLAY-LIST))
  633.        (HEI (CADDR DISPLAY-LIST))
  634.        (GRAPHICS-SHEET (MAKE-GRAPHICS-SHEET WID HEI))
  635.        (TURTLE-BOX (MAKE-INSTANCE 'GRAPHICS-BOX ':NAME NAME
  636.                       ':STATIC-VARIABLES-ALIST ENVIRONMENT
  637.                       ':GRAPHICS-SHEET GRAPHICS-SHEET))
  638. ;       (TURTLE (MAKE-TURTLE))
  639.        )
  640.       LOCAL-LIBRARY  ;the variable was bound but....
  641.       (SETF (GRAPHICS-SHEET-SUPERIOR-BOX GRAPHICS-SHEET) TURTLE-BOX)
  642. ;      (TELL TURTLE-BOX :ADD-GRAPHICS-OBJECT TURTLE)
  643.       (WHEN (NAME-ROW? NAME)
  644.     (TELL NAME :SET-SUPERIOR-BOX TURTLE-BOX))
  645.       (*CATCH 'DONE-WITH-BOX
  646.           (BIN-NEXT-VALUE STREAM) ;if this doesn't throw like it should we signal an error
  647.           (FERROR "the turtle box, ~S, was dumped with extraneous information"
  648.               TURTLE-BOX))
  649.       TURTLE-BOX)))
  650.  
  651. (DEFUN LOAD-TURTLE-BOX (STREAM RESTORE-P)
  652.   (IF RESTORE-P
  653.       (LOAD-TURTLE-BOX-WITH-STATE STREAM)
  654.       (LOAD-TURTLE-BOX-WITHOUT-STATE STREAM)))
  655.  
  656. (DEFUN LOAD-LL-BOX (STREAM)
  657.   (LOAD-VANILLA-BOX (STREAM)
  658.     (LET* ((FIRST-ROW (BIN-NEXT-VALUE STREAM))
  659.        (LL-BOX (MAKE-INSTANCE 'LL-BOX ':NAME NAME ':DISPLAY-STYLE-LIST DISPLAY-LIST
  660.                                       ':STATIC-VARIABLES-ALIST ENVIRONMENT
  661.                           ':FIRST-INFERIOR-ROW FIRST-ROW
  662.                           ':LOCAL-LIBRARY LOCAL-LIBRARY)))
  663.       (TELL (TELL LL-BOX :FIRST-INFERIOR-ROW) :SET-SUPERIOR-BOX LL-BOX)
  664.       ;; if it has a name and unput row, then we have to attach it to the box
  665.       (WHEN (NAME-ROW? NAME)
  666.     (TELL NAME :SET-SUPERIOR-BOX LL-BOX))
  667.       (*CATCH 'DONE-WITH-BOX
  668.     (LOOP DOING
  669.           (LET ((NEXT-STUFF (BIN-NEXT-VALUE STREAM)))
  670.         (COND ((ROW? NEXT-STUFF)
  671.                (TELL LL-BOX :APPEND-ROW NEXT-STUFF))
  672.               ((OR (EQ NEXT-STUFF *EXPORT-ALL-VARIABLES-MARKER*)
  673.                (LISTP NEXT-STUFF))
  674.                (TELL LL-BOX :SET-EXPORTS NEXT-STUFF))))))
  675.       LL-BOX)))
  676.  
  677. (DEFUN LOAD-GRAPHICS-SHEET (STREAM)
  678.   (IF (MEMBER *FILE-BIN-VERSION* '(1. 2.))
  679.       (LET* ((WID (BIN-NEXT-VALUE STREAM))
  680.          (HEI (BIN-NEXT-VALUE STREAM))
  681.          (ARRAY (BIN-NEXT-VALUE STREAM))
  682.          (OBJECTS (BIN-NEXT-VALUE STREAM))
  683.          (SHEET (MAKE-GRAPHICS-SHEET-FROM-FILE WID HEI ARRAY ':WRAP)))
  684. ;    (DOLIST (OBJECT OBJECTS)
  685. ;      ;; we don't send the :SET-ASSOCIATED-SHEET message because the sheet has not yet been
  686. ;      ;; connected to the box so it will lose when it tries to frob the environment
  687. ;      (SETF (MINIMUM-GRAPHICS-OBJECT-ASSOCIATED-SHEET OBJECT) SHEET))
  688.     OBJECTS ;; the variable was bound but never.....
  689.     SHEET)
  690.       ;; the new version instead
  691.       (LET* ((WID (BIN-NEXT-VALUE STREAM))
  692.          (HEI (BIN-NEXT-VALUE STREAM))
  693.          (ARRAY (BIN-NEXT-VALUE STREAM))
  694.          (DRAW-MODE (BIN-NEXT-VALUE STREAM))
  695.          (SHEET (MAKE-GRAPHICS-SHEET-FROM-FILE WID HEI ARRAY DRAW-MODE)))
  696.     SHEET)))
  697.  
  698. (DEFUN LOAD-GRAPHICS-OBJECT (STREAM)
  699.   (LET* ((FORM (BIN-NEXT-VALUE STREAM))
  700.      (PLIST (CDR FORM)))
  701.     (IF (NOT (MEMBER *FILE-BIN-VERSION* '(1. 2.)))
  702.     (INSTANTIATE-FLAVOR (CAR FORM) (LOCF PLIST) NIL)
  703.     ;; we need to convert the Plist to the new representation of graphics objects...
  704.     (REMPROP (LOCF PLIST) :COS-HEADING)
  705.     (REMPROP (LOCF PLIST) :SIN-HEADING)
  706.     (REMPROP (LOCF PLIST) :NAME)
  707.     (PUTPROP (LOCF PLIST) (NCONS (GET (LOCF PLIST) :PEN-MODE)) :PEN)
  708.     (REMPROP (LOCF PLIST) :PEN-MODE)
  709.     (SETF (GET (LOCF PLIST) :X-POSITION) (NCONS (GET (LOCF PLIST) :X-POSITION)))
  710.     (SETF (GET (LOCF PLIST) :Y-POSITION) (NCONS (GET (LOCF PLIST) :Y-POSITION)))
  711.     (SETF (GET (LOCF PLIST) :HEADING) (NCONS (GET (LOCF PLIST) :HEADING)))
  712.     (SETF (GET (LOCF PLIST) :SHOWN-P) (NCONS (GET (LOCF PLIST) :SHOWN-P)))
  713.     (INSTANTIATE-FLAVOR (CAR FORM) (LOCF PLIST) NIL))))
  714.  
  715. (DEFUN LOAD-TURTLE (STREAM)
  716.   (LET* ((FORM (BIN-NEXT-VALUE STREAM))
  717.      (PLIST (CDR FORM)))
  718.     (INSTANTIATE-FLAVOR (CAR FORM) (LOCF PLIST) NIL)))
  719.     
  720. ;;; Top level interface
  721.  
  722. (DEFUN LOAD-BINARY-BOX-INTERNAL (BOX PATHNAME)
  723.   (WITH-OPEN-FILE (FILESTREAM PATHNAME ':CHARACTERS NIL ':ERROR ':REPROMPT)
  724.     (LOADING-BIN-FILE (FILESTREAM 'BIN-LOAD-NEXT-COMMAND NIL)
  725.       (LET ((PACKAGE (PKG-FIND-PACKAGE 'BOXER)))
  726.     (BIN-LOAD-TOP-LEVEL FILESTREAM BOX))))) 
  727.  
  728. (DEFUN BIN-LOAD-TOP-LEVEL (STREAM &OPTIONAL(BOX (MAKE-BOX ())) &AUX BOX-TO-RETURN)
  729.   ;; presumably, the only thing left after the file's plist will be the top level box 
  730.   (*CATCH 'BIN-LOAD-DONE
  731.     (SETQ BOX-TO-RETURN (BIN-NEXT-VALUE STREAM))    ;top level box
  732.     (LOOP DOING (BIN-NEXT-COMMAND STREAM)))
  733.   (LET ((PLIST (TELL BOX-TO-RETURN :RETURN-INIT-PLIST-FOR-FILING))
  734.     (FIRST-ROW (TELL BOX-TO-RETURN :FIRST-INFERIOR-ROW)))
  735.     ;; we have to move the guts of BOX-TO-RETURN to the box which is already there
  736.     (TELL BOX :SEMI-INIT (LOCF PLIST))
  737.     (TELL BOX :SET-FIRST-INFERIOR-ROW FIRST-ROW)
  738.     (DOLIST (ROW (TELL BOX-TO-RETURN :ROWS))
  739.       (TELL ROW :SET-SUPERIOR-BOX BOX))
  740.     ;; now we transfer the bindings to the already existing box
  741.     (TELL BOX :SET-STATIC-VARIABLES-ALIST (TELL BOX-TO-RETURN :GET-STATIC-VARIABLES-ALIST))
  742.     ;; as well as the local library
  743.     (TELL BOX :SET-LOCAL-LIBRARY (TELL BOX-TO-RETURN :LOCAL-LIBRARY))
  744.     BOX))
  745.  
  746. (DEFUN DECODE-BIN-OPCODE (WORD)
  747.   (LET ((HIGH (LDB %%BIN-OP-HIGH WORD))
  748.     (LOW (LDB %%BIN-OP-LOW WORD)))
  749.     (IF (OR (= HIGH BIN-OP-COMMAND-IMMEDIATE) (= HIGH BIN-OP-BOX-IMMEDIATE))
  750.     LOW
  751.     (VALUES HIGH LOW))))
  752.  
  753. (DEFUN BIN-LOAD-START (STREAM &OPTIONAL SKIP-READING-PROPERTY-LIST)
  754.   (LET ((WORD (BIN-NEXT-BYTE STREAM)))
  755.     (OR (= WORD BIN-OP-FORMAT-VERSION)
  756.     (FERROR NIL "~A is not a BIN file" (FUNCALL STREAM ':TRUENAME)))
  757.     (FUNCALL STREAM ':UNTYI WORD)
  758.     (BIN-NEXT-COMMAND STREAM))
  759.   ;; Read in the file property list before choosing a package.
  760.   (UNLESS SKIP-READING-PROPERTY-LIST
  761.     (LET ((WORD (BIN-NEXT-BYTE STREAM)))
  762.       (FUNCALL STREAM ':UNTYI WORD)
  763.       (AND (= WORD BIN-OP-FILE-PROPERTY-LIST)
  764.        (BIN-NEXT-COMMAND STREAM)))))
  765.  
  766.  
  767. (DEFUN ENTER-BIN-LOAD-TABLE-INTERNAL (VALUE INDEX)
  768.   (AND ( INDEX (ARRAY-LENGTH *BIN-LOAD-TABLE*))
  769.        (ADJUST-ARRAY-SIZE *BIN-LOAD-TABLE* (* 2 (ARRAY-LENGTH *BIN-LOAD-TABLE*))))
  770.   (ASET VALUE *BIN-LOAD-TABLE* INDEX)
  771.   VALUE)
  772.  
  773. (DEFUN BIN-NEXT-BYTE (STREAM)
  774.   (SEND STREAM ':TYI "Unexpected end of file before logical end of binary data"))
  775.  
  776. (DEFUN BIN-LOAD-NEXT-COMMAND (STREAM)
  777.   (MULTIPLE-VALUE-BIND (INDEX EXTRA-ARG)
  778.       (DECODE-BIN-OPCODE (BIN-NEXT-BYTE STREAM))
  779.     (LET ((FUNCTION (BIN-OP-DISPATCH *BIN-OP-LOAD-COMMAND-TABLE* INDEX)))
  780.       (IF EXTRA-ARG
  781.       (FUNCALL FUNCTION STREAM EXTRA-ARG)
  782.       (FUNCALL FUNCTION STREAM)))))
  783.  
  784. (DEFUN BIN-NEXT-VALUE (STREAM)
  785.   (DO (VAL1 VAL2 VAL3) (NIL)
  786.     (MULTIPLE-VALUE (VAL1 VAL2 VAL3)
  787.       (BIN-NEXT-COMMAND STREAM))
  788.     (OR (EQ VAL1 *NO-VALUE-MARKER*)
  789.     (RETURN (VALUES VAL1 VAL2 VAL3)))))
  790.